perm filename PPSRT.F4[XX,LCS]2 blob sn#182703 filedate 1975-10-20 generic text, type T, neo UTF8
00100	C  SUBRS.  SLUR, PLTSRT, (LINES, RDRAW)
00200	
06300		SUBROUTINE SLUR
06382		IMPLICIT INTEGER(A-Q,T-Z)
06464		COMMON/SLR/ SLURX(72) /ALF/INP,SLURY(72)
06546		REAL CENTR
06628		COMMON /PLTR/PLT,RHT,RDIS
06710		COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
06792		1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
06874		1 J5,J6,J7,J8,J9,J10,J11,JQ(8),R
06956		COMMON/PTR/PWDS(250),ITEM,L,I,IX /STF/RSTFAC(-3/4),RSTJ2
07120	CF	DATA RZZ/2.8/
07202	C  DEFAULT VALUE OF SLUR CURVE FACTOR IS 2.8
07284	
07366		IF(JA.NE.12)GO TO 2
07380	CF	RA=5.96*RSJT2*R5
07451	CF	L=3
07522	CF	J8=J8*RDIS
07593	CF	IF(J7.LE.J6)J7=J7+360
07664	CF	KQ=6
07735	CF	IF(PLT)KQ=1
07806	CF10	DO 3 K=J6,J7,KQ
07877	CF	R=K
07948	CF	CALL LINES(R3+RA*SIND(R),CENTR+RA*COSD(R),L)
08019	CF3	L=2
08090	CF	J8=J8-1
08161	CF	IF(J8)RETURN
08232	CF	RA=RA+1/RDIS
08303	CF	L=3
08374	CF	GO TO 10
08445	CJA=12  DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2,P8=THICK(EXPANDS
08516		CALL CIRCLE
08678		RETURN
08760	
08842	2	J10=1
08850		J4=-1
08924		KQ=6
09006		TWICE=-1
09088	C  -1 FOR DISPLAY, USES ONLY 1/3 OF SEGMENTS
09170		IF(PLT.GE.0)GO TO 21
09252		TWICE=0
09334		KQ=1
09416		RWID=.2
09498		IF(RHT.LT.2)GO TO 21
09580		TWICE=1
09662		RWID=.14
09744	C  IF SIZE IS GT.2 3 SLURS ARE DRAWN
09826	21	RST7=RSTJ2*7.
09900		RQQ=R5-R4
09908		IF(R6.GT.1000)CALL RNOTE(R6)
09990		GO TO (5,6,7),J8+4
10072		GO TO 4
10154	5	R=32
10236	C AFTER DOTTED NOTE
10318		GO TO 8
10400	6	R=22
10482	C BETWEEN NOTES
10564	8	RX=-1.3
10646		GO TO 9
10728	7	R=7
10810		RX=RSTJ2
10892	9	CALL RJBX(R)
10974		R6=R6+RX
11056	4	RXX=RHORZ(R6)-R3
11138		RTILT=RQQ*RST7
11220	80	RX=SQRT(RXX**2+RTILT**2)
11230		IF(J8.NE.-1)GO TO 1
11240		IF(RQQ.GT.8)RQQ=8
11250		IF(RQQ.LT.-8)RQQ=-8
11260		RQQ=RQQ*RSTFAC(J2)*1.0
11270		IF(R7)RQQ=-RQQ
11280		R3=R3-RQQ
11290	C  MOVES STEEP SLUR LEFT OR RIGHT IF P8=-1
11302	1	R=CENTR
11384		IF(J8.GT.0)GO TO 180
11385		L=72
11466	C  FOR BRACKETS
11508		CALL SLOOP
11550	CF	RB=RX/71.
11641	CF	DO 81 K=0,71
11732	CF81	SLURX(K+1)=RB*(K)+R3
11823	CF	RA=R7*RST7
11914	CF41	IF(R9.EQ.0)R9=RZZ
12005	CF	R=R+RA
12096	CF	L=0
12187	CF	DO 40 K=36,1,-1
12278	CF	L=L+1
12369	CF	RW=R-RA*(K/36.)**R9
12460	CF	SLURY(L)=RW
12551	CF40	SLURY(73-L)=RW
12642	CF	L=72
12733	
12824	CF89	IF(RTILT.EQ.0)GO TO 87
12915	CF	RW=ATAN2(RTILT,RXX)
13006	CF	RA=SIN(RW)
13097	CF	RB=COS(RW)
13188	CF	RZ=SLURX(1)
13279	CF	RW=SLURY(1)
13370	CF	DO 83 K=1,L
13461	CF	R=SLURX(K)-RZ
13552	CF	RXX=SLURY(K)-RW
13643	CF	SLURX(K)=RB*R-RA*RXX+RZ
13734	CF83	SLURY(K)=RB*RXX+RA*R+RW
13844	
13926	87	IF(J4)CALL LINES(SLURX(J10),SLURY(J10),3)
13967		J5=KQ
13987		J6=J10
13997		J7=L
14000		IF(J4.NE.0)GO TO 22
14010		CALL EXCH(J6,J7)
14020		J5=-1
14080	22	DO 88 K=J6,J7,J5
14090	88	CALL LINES(SLURX(K),SLURY(K),2)
14336		IF(TWICE)RETURN
14450		TWICE=TWICE-1
14470		IF(J8.GT.0)GO TO 182
14490		J4=J4+1
14510		R7=R7+RWID
14530	C  RWID=WIDTH OF SLUR -- SEE DATA
14550		GO TO 1
14570	180	RW=R+R7*RST7
14590		TWICE=-1
14610		KQ=1
14630		RX=RX+R3
14650	CC	RA=(R5-R4)*RST7
14670		IF(J9.EQ.0)GO TO 181
14690		TWICE=2
14710		RZ=RTILT/(RX-R3)
14730		RXX=RX
14750		RWID=(R3+RXX)/2.
14770	182	IF(TWICE.EQ.1)GO TO 183
14790	C  DOES LEFT SIDE FIRST.
14810		IF(TWICE.EQ.0)GO TO 184
14830	C LAST IS NUMBER.
14850		J8=2
14860		RC=RSTJ2*13.
14870		RX=RWID-RC
14890		RWW=RTILT
14910	185	RTILT=RZ*(RX-R3)
14930	
14950	C  PUT IN FUNC. HERE FOR THIS SLOPE AND FOR PART. BEAMS.
14970	
14990		GO TO 181
15010	183	J8=3
15030		RX=RXX
15050		RTILT=RWW
15070		RXX=R3
15090		R3=RWID+RC
15110		RXX=RZ*(R3-RXX)
15130		R=R+RXX
15150		RW=RW+RXX
15170		GO TO 185
15190	
15210	181	SLURX(1)=R3
15230		SLURY(1)=R
15250		SLURX(2)=R3
15270		SLURY(2)=RW
15290		SLURX(3)=RX
15310		SLURY(3)=RW+RTILT
15330		SLURX(4)=RX
15350		SLURY(4)=R+RTILT
15370		L=4
15390		IF(J8.EQ.2)L=3
15410		IF(J8.EQ.3)J10=2
15430	CC	TWICE=-1
15450		GO TO 87
15470	184	J3=RWID
15490	C  PUT IN VERT. POS. WHEN SLOPE!
15510		R4=RQQ/2.+R4+R7-1.
15530		R6=1.
15550		R7=1.
15560		R8=0
15570		CALL MAKNUM(R9)
15590		END
16300	C  8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
16400	C        FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
16500	
16600	
17400		SUBROUTINE PLTSRT
17500	C  SORTS DATA TO SHORTEN INVISIBLE VECTORS WHEN PLOTTING. 
17600	CF	IMPLICIT INTEGER(S-Z)
17700		COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
17800		DIMENSION  P(250)
17810		CALL PSRT(P)
17820		END
17830	
17900	CF	DO 4 K=1,ITEM
18000	CF	L=PWDS(K)
18050	CF	LL=PWDS(K-1)
18060	CF	LM=PWDS(K+1)
18100	CF	A=RN(L+3)
18200	CF	P(K)=A+1000*RN(L+2)
18210	CF	IF(RN(L+1).NE.16)GO TO 40
18220	CF	Y=PWDS(K-1)
18230	CF	V=PWDS(K+1)
18240	CF	IF(RN(Y+1).EQ.16)GO TO 41
18245	CF	IF(RN(V+1).EQ.16)GO TO 41
18250	CF	GO TO 4
18300	CF40	IF(A.GE.0)GO TO 4
18305	CF41	P(K)=-10000
18310	CF4	CONTINUE
18400	C  PLOTS ALL NEG. POSITIONS FIRST.
18425	CF	IX=I
18450	CF	IF(I.LT.1500)I=1500
18500	CF	Y=I
18537	CF	I=I+IX-1
18556	CF	IX=Y
18565	C  IX IS M IN MAIN PROG.
18575	C  LEAVES 1500 WDS IN RN FOR STORING "NOIR" DATA.
18600	CF2	A=P(1)
18700	CF	L=1
18800	CF	DO 1 K=1,ITEM
18900	CF	IF(A.LE.P(K))GO TO 1
19000	CF	A=P(K)
19100	CF	L=K
19200	CF1	CONTINUE
19300	CF	IF(A.EQ.10000.)RETURN
19400	C  ALL ITEMS HAVE NOW BEEN SHUFFLED
19500	CF	V=PWDS(L)
19600	CF	P(L)=10000
19700	CF	L=RN(V)+2+Y
19750	CF	V=V-Y
19800	CC	CALL LOOP(0,L,1,Y,V,RN)
19810	CF	DO 3 K=Y,L
19820	CF3	RN(K)=RN(K+V)
19830	C  REPLACED SUBROUTINE LOOP
19900	CF	Y=L+1
20000	CF	GO TO 2
20100	CF	END
20200	
20300	
20400	CX	SUBROUTINE LINES(A,B,L)
20500	CX	COMMON /FL/IC,NZ,NX,RZ,XGP
20600	CX	COMMON/DL/IIII,SAVER,AA /PLTR/IPLT,RHT,DIS
20700	CX	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) 
20800	CX	COMMON/DPY/GO,TOP,BOT
20900	CX	DATA BB/260.0/,CC/3.5/,DD/1.43/,MX/512/
21000	C  SET XGP TO 1245.0 FOR MARGIN IN XEROX COPIES
21100	CX22	GO TO 23
21200	C  CHANGE ABOVE TO 'J6CL' IN DDT TO USE NEXT ITEMS.
21300	CX24	AA=CC-DD*ABS(A)/BB
21400	C  USE THIS IN DDT TO DISTORT ITEMS.  CC MUST BE > DD
21500	CX	B=B*AA
21600	CX23	IF(IPLT)GO TO 2
21900	CX	IF(JA.EQ.44)RETURN
22000	CC	K=B
22100	CC	IF(K.GT.ITOP)ITOP=B
22200	CC	IF(K.LT.IBOT)IBOT=B
22220	CX	IF(B.GT.TOP)TOP=B
22240	CX	IF(B.LT.BOT)BOT=B
22300	CX6	RETURN
22400	CC2	IF(IPLT.EQ.-2)RETURN
22500	C RXGP SETS UP-DOWN POS. ON XEROX PAPER (FRACTIONAL POSITIONS POSSIBLE.)
22600	CC	IF(IXRX.EQ.0)GO TO 9
22700	CC	M=ROFF(RXGP-B*RHT)
22800	CC	N=ROFF(XGP+A*DIS)
22900	CC	GO TO 8
23000	CX2	M=ROFF(A*DIS)
23100	CX	N=ROFF(B*RHT)
23200	CX8	CALL PLOT(M,N,L)
23300	CX	END